(CDEFUN ACHIEVE ('GOAL)
   (COND ((TRUE GOAL) (RETURN 'ALREADY-TRUE))
         ((TRY-NEXT (FETCHM !"(IMPERATIVE-FOR ,GOAL)))
          (RETURN 'OK)))
   (WRITE GOAL (FRAME)))

(CDEFUN MAKE ('GOAL)
   (COND ((TRY-NEXT (FETCHM !"(IMPERATIVE-FOR ,GOAL)))
          (RETURN 'OK)))
   (WRITE GOAL (FRAME)))

(CDEFUN WRITE (GOAL FR) "AUX"(CODE POS (REASON (EXPRESSION FR)) (REJ ()))
   (TERPRI)
   (CPRINT !"(NEED CODE FOR ,GOAL))
   (COND ((NOTICED GOAL) (CEVAL REASON) (RETURN 'OK))
         ((TRY-NEXT (FETCHM !"(CODE-FOR ,GOAL !CODE)))
          (DISPLACE REASON !"(@(REASON ,REASON) ,GOAL ,CODE))
          (CEVAL REASON)
          (RETURN 'OK))
         ((TRY-NEXT (FETCHM !"(MEANING-OF ,GOAL !CODE)))
          (CSETQ CODE !"(@(REASON ,REASON) ,GOAL
                            (MEANS ,CODE (MAKE ,CODE))))
          (NOTICE REASON CODE)
          (CEVAL CODE)
          (RETURN 'OK)))
   (CSETQ POS (FETCHM !"(SUFFICES-FOR ,GOAL !CODE)))
 :SUFLP
   (COND ((TRY-NEXT POS)
          (COND ((TRUE CODE) (LISTEN 'LOSING-SUFCON)))
          (CSETQ CODE !"(@(REASON ,REASON) ,GOAL
                            (NEED-ONLY ,CODE (MAKE ,CODE))))
          (NOTICE REASON CODE)
          (PUTP CODE POS 'ALTSUF)
          (CEVAL CODE)
          (RETURN 'OK)))
   (CSETQ POS (FETCHM !"(MAY-HURT ,GOAL !CODE)))
 :STRLP
   (COND ((TRY-NEXT POS)
          (COND ((TRUE !"(NOT ,CODE)) 
                 (CSETQ REJ (NCONC REJ (LIST (CADR POS))))
                 (GO 'STRLP)))
          (CSETQ CODE !"(@(REASON ,REASON) ,GOAL
                             (STRATEGY (NOT ,CODE) (MAKE (NOT ,CODE)))))
          (NOTICE REASON CODE)
          (PUTP CODE (NCONC POS REJ) 'ALTSTRAT)
          (CEVAL CODE)
          (RETURN 'OK)))
   (WORRY COULD-NOT REASON))

(CDEFUN RAN-OUT () "AUX" ((T1 (TAG 'LP)) (EXP (EXPRESSION T1)) CODE POS (REJ ()))
   (TERPRI)
   (CPRINT !"(NEED ANOTHER WAY TO GET @(CADR ,EXP)))
   (COND ((CSETQ POS (GETP EXP 'ALTSUF)) (CSETQ POS (CADR POS)) (GO 'SUFLP))
         ((CSETQ POS (GETP EXP 'ALTSTRAT)) (CSETQ POS (CADR POS)) (GO 'STRLP)))
   (CSETQ POS (FETCHM !"(SUFFICES-FOR @(CADR ,EXP) !CODE)))
 :SUFLP
   (COND ((TRY-NEXT POS)
          (COND ((TRUE CODE) (LISTEN 'LOSING-SUFCON)))
          (CSETQ CODE !"((NEED-ONLY ,CODE (MAKE ,CODE))))
          (PUTP EXP POS 'ALTSUF)
          (NCONC EXP CODE)
          (CSET 'CODE CODE T1)
          (GO T1)))
   (CSETQ POS (FETCHM !"(MAY-HURT @(CADR ,EXP) !CODE)))
 :STRLP
   (COND ((TRY-NEXT POS)
          (COND ((TRUE !"(NOT ,CODE))
                 (CSETQ REJ (NCONC REJ (LIST (CADR POS))))
                 (GO 'STRLP)))
          (CSETQ CODE !"((STRATEGY (NOT ,CODE) (MAKE (NOT ,CODE)))))
          (PUTP EXP (NCONC POS REJ) 'ALTSTRAT)
          (NCONC EXP CODE)
          (CSET 'CODE CODE T1)
          (GO T1)))
   (WORRY COULD-NOT EXP))

(DEFUN NOTICE (REASON CODE)
   (PROG (P C N)
      (SETQ C (CONS (CAR REASON) (CDR REASON)))
      (DISPLACE REASON CODE)
      (EVAL !"(IF-NEEDED @(SETQ N (GENV)) (NOTICE @(SETQ P (EXCL (CADR CODE))))
                      (KILL (CAR (EXPRESSION (FRAME))))
                      (CIMP @REASON @CODE @P @C)
                      (ADIEU T)))
      (INSERT N)))

(DEFUN EXCL (P)
   (COND ((ATOM P) P)
         ((EQ (CAR P) '/!/,) (LIST '/! (CADR P)))
         (T (CONS (EXCL (CAR P)) (EXCL (CDR P))))))

(DEFUN CIMP FEXPR (L) (PROG (N)
   (SETQ N (GENV))
   (TERPRI)
   (PRINT '(NOTICED POSSIBLE SUBROUTINE))
   (DISPLACE (CAR L) (CADDDR L))
   (SPEW (SETQ NC !"(IF-NEEDED @N (IMPERATIVE-FOR @(CADDR L))
	                @(CADR L)
	                (ADIEU T))))
   (EVAL NC)
   (INSERT N)))

(CDEFUN NOTICED (GOAL) (TRY-NEXT (FETCHM !"(NOTICE ,GOAL))))

(DEFUN REASON (R)
   (COND ((EQ (CAR R) 'MAKE) 'TO-MAKE)
         ((EQ (CAR R) 'ACHIEVE) 'TO-ACHIEVE)
         (T (CERR REASON))))

(COMMENT DEBUGGING)

(CDEFUN BUG ('TYPE 'IRRITANT)
   (CSETQ IRRITANT (!$/!"1 IRRITANT))
   (CPRINT !"(BUG ,TYPE ,IRRITANT))
   (TRY-NEXT (FETCHM !"(,TYPE ,IRRITANT)))
   (LISTEN  !"(DO NOT KNOW HOW TO DEBUG ,TYPE)))

(IF-NEEDED BUG-U-P (UNSATISFIED-PREREQUISITE !X)
   (CSETQ ORIG (FRAME))
   (NEEDBACK))

(CDEFUN NEEDBACK () "AUX"((N (VFRAME 'NECESSARY)))
   (COND (N (CEVAL '(GO 'BACK) N))
         (T (LISTEN 'UNDECLARED-PREREQUISITE--ORIG))))

(CDEFUN SCREWED ()
   (LISTEN 'PREREQUISITE-LOST-BETWEEN-HERE-AND-ORIG))

βββββββββββββββββββββββββββββββββββββββββ